home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 9 / CDACTUAL9.iso / share / Dos / VARIOS / pascal / SWAG9605.DDD / 0030_Morphing lines.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-05-31  |  3.7 KB  |  166 lines
  1. uses crt,gru,lines;  { GRU in GRAPHICS.SWG .. see end for lines }
  2.  
  3. const
  4.   col=1;
  5.   dc1=10;
  6.  
  7. var
  8.   vseg:word;
  9.   virt:pointer;
  10.   work,grav,dist:coords;
  11.   timer:longint absolute $0040:$006c;
  12.   frame,t1,t2:longint;
  13.  
  14. procedure plotem(c0:coords);
  15. begin
  16.   with c0 do
  17.   begin
  18.     line2(a1,a2,d1,d2,vseg,col);
  19.     line2(d1,d2,c1,c2,vseg,col);
  20.     line2(c1,c2,b1,b2,vseg,col);
  21.     line2(b1,b2,a1,a2,vseg,col);
  22.   end;
  23. end;
  24.  
  25. procedure animate;
  26. begin
  27.   clear386(vseg,0);
  28.   plotem(work);
  29.   flip386(vseg,vidseg);
  30. end;
  31.  
  32. procedure morfun;
  33. var
  34.   cnt:longint;
  35.   d:boolean;
  36. begin
  37.   repeat
  38.     mutate(work);
  39.     distort(work);
  40.     morphit(work,grav);
  41.     mutate(work);
  42.     distort(work);
  43.     morphit(work,dist);
  44.     animate;
  45.     inc(frame);
  46.   until(keypressed);
  47.   readkey;
  48. end;
  49.  
  50. var
  51.   y:word;
  52.  
  53. begin
  54.   clipon:=true;
  55.   randomize;
  56.   randfig(work);
  57.   randfig(dist);
  58.   with grav do
  59.   begin
  60.     a1:=160; a2:=99; b1:=165; b2:=105;
  61.     c1:=180; c2:=115; d1:=150; d2:=85;
  62.   end;
  63.   setmode($13);
  64.   getmem(virt,64000);
  65.   vseg:=seg(virt^);
  66.   frame:=0;
  67.   t1:=timer;
  68.   morfun;
  69.   t2:=(timer-t1);
  70.   setmode($03);
  71.   writeln(round((frame*18.2)/t2),' fps.');
  72. end.
  73.  
  74. { -----------------------  LINES ---------------------- }
  75. unit lines;
  76.  
  77. INTERFACE
  78.  
  79. type
  80.   coords=record
  81.            a1,a2,b1,b2,c1,c2,d1,d2:word;
  82.          end;
  83.  
  84. function morphit(var c0:coords;c02:coords):boolean;
  85. procedure distort(var c0:coords);
  86. procedure mutate(var c0:coords);
  87. procedure randfig(var c0:coords);
  88.  
  89. IMPLEMENTATION
  90.  
  91. function figure(var a,b:word):boolean;
  92. begin
  93.   figure:=false;
  94.   if(a<>b)then
  95.   begin
  96.     if(a>b)then dec(a)else inc(a);
  97.     exit;
  98.   end;
  99.   { We'll end up here if a=b. }
  100.   figure:=true;
  101. end;
  102.  
  103. function morphit(var c0:coords;c02:coords):boolean;
  104. begin
  105.   morphit:=false;
  106.   with c0 do
  107.   begin
  108.     {$b+}  { We need FULL boolean evalution for this little trick :-) }
  109.     if(figure(a1,c02.a1))and
  110.     (figure(a2,c02.a2))and
  111.     (figure(b1,c02.b1))and
  112.     (figure(b2,c02.b2))and
  113.     (figure(c1,c02.c1))and
  114.     (figure(c2,c02.c2))and
  115.     (figure(d1,c02.d1))and
  116.     (figure(d2,c02.d2))then morphit:=true;
  117.     {$b-}
  118.   end;
  119. end;
  120.  
  121. procedure distort(var c0:coords);
  122. var amount:byte;
  123. begin
  124.   amount:=random(3);
  125.   with c0 do
  126.   begin
  127.     if(random(2)=1)and(a1+amount<319)then inc(a1,amount)else if(a1>amount)then dec(a1,amount);
  128.     if(random(2)=1)and(b1+amount<319)then inc(b1,amount)else if(b1>amount)then dec(b1,amount);
  129.     if(random(2)=1)and(c1+amount<319)then inc(c1,amount)else if(c1>amount)then dec(c1,amount);
  130.     if(random(2)=1)and(d1+amount<319)then inc(d1,amount)else if(d1>amount)then dec(d1,amount);
  131.     if(random(2)=1)and(a2+amount<319)then inc(a2,amount)else if(a2>amount)then dec(a2,amount);
  132.     if(random(2)=1)and(b2+amount<319)then inc(b2,amount)else if(b2>amount)then dec(b2,amount);
  133.     if(random(2)=1)and(c2+amount<319)then inc(c2,amount)else if(c2>amount)then dec(c2,amount);
  134.     if(random(2)=1)and(d2+amount<319)then inc(d2,amount)else if(d2>amount)then dec(d2,amount);
  135.   end;
  136. end;
  137.  
  138. procedure mutate(var c0:coords);
  139. begin
  140.   with c0 do
  141.   begin
  142.     case random(20) of
  143.       2: if(a1<314)then inc(a1,random(5));
  144.       4: if(b1<314)then inc(b1,random(5));
  145.       6: if(c1<313)then inc(c1,random(6));
  146.       8: if(d1<313)then inc(d1,random(6));
  147.       10:if(a1>8)then dec(a1,random(7));
  148.       12:if(b1>8)then dec(b1,random(7));
  149.       14:if(c1>9)then dec(c1,random(8));
  150.       16:if(d1>9)then dec(d1,random(8));
  151.     end;
  152.   end;
  153. end;
  154.  
  155. procedure randfig(var c0:coords);
  156. begin
  157.   with c0 do
  158.   begin
  159.     a1:=random(100); a2:=random(50);
  160.     b1:=succ(a1)+random(220); b2:=random(50);
  161.     c1:=160+random(160); c2:=succ(b2)+random(150);
  162.     d1:=random(160); d2:=succ(a2)+random(150);
  163.   end;
  164. end;
  165.  
  166. end.